home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / smooth / paltest.bas < prev    next >
BASIC Source File  |  1997-02-23  |  7KB  |  241 lines
  1. '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  2. '@           Smooth Fade Bas By WILDeHACK (WILDeHACK@aol.com)
  3. '@  Modified From Module Received from Daniel Appleman
  4. '@  From his Book "Visual Basic Programmer's Guide to the Window's API"
  5. '@
  6. '@
  7. '@ Use At your Own Risk
  8. '@
  9. '@ Steps to do this
  10. '@ 1) Put a pictureBox on your form ans Call it "faded"
  11. '@ 2) Place that picturebox in the upper-left corner of the screen, touching the sides
  12. '@ 3) In the form_Load event, add this code: TheFormLoad me
  13. '@ 4) In the Form_Resize Event, add this code: ResizeTheForm me
  14. '@ 5) In the Picture_Paint Event, add this:  FillPicture Me
  15. '@ 6) You should be set
  16. '@
  17. '@  Check out |
  18. '@            |
  19. '@            \/
  20.  
  21.  
  22. 'Mess with this number to determine the number of sections to be contructed
  23. 'The greater the number, the smoother the fade
  24. Global Const PALENTRIES = 64
  25.  
  26.  
  27.  
  28.  
  29.  
  30. Type POINTAPI  '4 Bytes - Synonymous with LONG
  31.     X As Integer
  32.     y As Integer
  33. End Type
  34.  
  35. Type SIZEAPI  '4 Bytes - Synonymous with LONG
  36.     X As Integer
  37.     y As Integer
  38. End Type
  39.  
  40. ' ParameterBlock description structure for use with LoadModule
  41. Type PARAMETERBLOCK  '14 Bytes
  42.     wEnvSeg As Integer
  43.     lpCmdLine As Long
  44.     lpCmdShow As Long
  45.     dwReserved As Long
  46. End Type
  47.  
  48.  
  49. '  GDI Logical Objects:
  50.  
  51. '  Pel Array
  52. Type PELARRAY  ' 10 Bytes
  53.     paXCount As Integer
  54.     paYCount As Integer
  55.     paXExt As Integer
  56.     paYExt As Integer
  57.     paRGBs As Integer
  58. End Type
  59.  
  60. '  Logical Brush (or Pattern)
  61. Type LOGBRUSH     '8 Bytes
  62.     lbStyle As Integer
  63.     lbColor As Long
  64.     lbHatch As Integer
  65. End Type
  66.  
  67. '  Logical Pen
  68. Type LOGPEN    '10 Bytes
  69.     lopnStyle As Integer
  70.     lopnWidth As POINTAPI
  71.     lopnColor As Long
  72. End Type
  73.  
  74. Type PALETTEENTRY    '4 Bytes
  75.     peRed As String * 1
  76.     peGreen As String * 1
  77.     peBlue As String * 1
  78.     peFlags As String * 1
  79. End Type
  80.  
  81. '  Logical Palette
  82. Type LOGPALETTE
  83.     palVersion As Integer
  84.     palNumEntries As Integer
  85.     palPalEntry As String * 252 ' Array length is arbitrary; may be changed
  86. End Type
  87. ' Project PalTest
  88.  
  89. ' Module containing global contstants and general purpose
  90. ' routines.
  91. Declare Function SetClipboardData Lib "User" (ByVal wFormat As Integer, ByVal hMem As Integer) As Integer
  92. Declare Function CloseClipboard Lib "User" () As Integer
  93. Declare Function OpenClipboard Lib "User" (ByVal hWnd As Integer) As Integer
  94. Declare Sub AnimatePalette Lib "GDI" (ByVal hPalette%, ByVal wStartIndex%, ByVal wNumEntries%, lpPaletteColors As PALETTEENTRY)
  95. Declare Function SendMessageByNum& Lib "User" Alias "SendMessage" (ByVal hWnd%, ByVal wMsg%, ByVal wParam%, ByVal lParam&)
  96. Option Explicit
  97. Global Const PC_RESERVED = &H1
  98. Global Const PC_EXPLICIT = &H2
  99. Global Const PC_NOCOLLAPSE = &H4
  100. Global Const DIB_RGB_COLORS = 0
  101. Global Const DIB_PAL_COLORS = 1
  102. Global Const SYSPAL_STATIC = 1
  103. Global Const SYSPAL_NOSTATIC = 2
  104. Global Const CF_TEXT = 1
  105. Global Const CF_BITMAP = 2
  106. Global Const CF_METAFILEPICT = 3
  107. Global Const CF_SYLK = 4
  108. Global Const CF_DIF = 5
  109. Global Const CF_TIFF = 6
  110. Global Const CF_OEMTEXT = 7
  111. Global Const CF_DIB = 8
  112. Global Const CF_PALETTE = 9
  113. Global Const CF_OWNERDISPLAY = &H80
  114. Global Const CF_DSPTEXT = &H81
  115. Global Const CF_DSPBITMAP = &H82
  116. Global Const CF_DSPMETAFILEPICT = &H83
  117. Global Const CF_PRIVATEFIRST = &H200
  118. Global Const CF_PRIVATELAST = &H2FF
  119.  
  120.  
  121. '   This is similar to the LOGPALLETTE defined in
  122. '   APIDECS.BAS, however instead of using a buffer, we
  123. '   create a 64 entry palette for our use.
  124.  
  125. Type LOGPALETTE64
  126.     palVersion As Integer
  127.     palNumEntries As Integer
  128.     palPalEntry(PALENTRIES) As PALETTEENTRY
  129. End Type
  130.  
  131. ' And create a type safe alias to create palette that handles this structure
  132. Declare Function CreatePalette64% Lib "GDI" Alias "CreatePalette" (lpLogPalette As LOGPALETTE64)
  133.  
  134.  
  135. ' The six palettes that this program will use are defined here
  136. Global UsePalettes%
  137. Global logPalettes As LOGPALETTE64
  138.  
  139. ' This is a message used within Visual Basic to retrieve
  140. ' the handle of a palette
  141. Global Const VBM_GETPALETTE% = &H101C
  142.  
  143. '   This function creates 6 palettes that are used by
  144. '   the PalTest program
  145. '
  146. Sub CreateAllPalettes ()
  147.     Dim entrynum%
  148.     Dim oldmouseptr%
  149.     Dim X%
  150.  
  151.     oldmouseptr% = Screen.MousePointer
  152.     Screen.MousePointer = 11
  153.     ' Initialize the logical palette
  154.     
  155.     logPalettes.palVersion = &H300
  156.     logPalettes.palNumEntries = PALENTRIES
  157.     
  158.     For entrynum% = 0 To PALENTRIES - 1
  159.     logPalettes.palPalEntry(entrynum%).peRed = Chr$(0)
  160.     logPalettes.palPalEntry(entrynum%).peGreen = Chr$(0)
  161.     logPalettes.palPalEntry(entrynum%).peBlue = Chr$((255 * entrynum%) / PALENTRIES)
  162.     logPalettes.palPalEntry(entrynum%).peFlags = Chr$(PC_RESERVED)
  163.     Next entrynum%
  164.  
  165.  
  166.     ' And create the palettes
  167.   
  168.     UsePalettes = CreatePalette64(logPalettes)
  169.     Screen.MousePointer = oldmouseptr%
  170. End Sub
  171.  
  172. '   FillPicture draws a spectrum in the specified picture
  173. '   control using the appropriate palette for that control
  174. '
  175. Sub FillPicture (asdf As Form)
  176.     Dim totwidth&, startloc&, endloc&
  177.     Dim pic As control
  178.     Dim X&
  179.     'Dim rc As RECT
  180.     'Dim usebrush%
  181.     'Dim t%
  182.  
  183.     Set pic = asdf.faded
  184.  
  185.     totwidth& = pic.ScaleHeight
  186.     For X& = 0 To PALENTRIES - 1
  187.     ' We're using long arithmetic for speed. Note the
  188.     ' ordering of operations to preserve precesion
  189.     startloc& = (totwidth& * X&) / PALENTRIES
  190.     endloc& = (totwidth& * (X& + 1)) / PALENTRIES
  191.     pic.Line (0, startloc&)-(pic.ScaleWidth, endloc&), GetPalColor(X&), BF
  192.     Next X&
  193.  
  194. End Sub
  195.  
  196. '
  197. '   Gets the Long RGB color for a palette entry
  198. '
  199. Function GetPalColor& (entry&)
  200.     Dim res&
  201.     Dim pe As PALETTEENTRY
  202.     LSet pe = logPalettes.palPalEntry(entry&)
  203.     ' We build a long value using this rather awkward
  204.     ' shifting technique.
  205.     ' We actually could save time by performing a raw
  206.     ' memory copy from the pe object into a long variable.
  207.     ' since they are the same format.
  208.     res& = Asc(pe.peRed)
  209.     res& = res& Or (Asc(pe.peGreen) * 256&)
  210.     res& = res& Or (Asc(pe.peBlue) * 256& * 256&)
  211.     GetPalColor& = res&
  212. End Function
  213.  
  214. Sub resizetheform (pop As Form)
  215. pop.faded.Height = pop.Height
  216. pop.faded.Width = pop.Width
  217. End Sub
  218.  
  219. Sub TheFormLoad (xyz As Form)
  220.     xyz.faded.Height = xyz.Height
  221.     xyz.faded.Width = xyz.Width
  222.     Dim X%, h%
  223.  
  224.     CreateAllPalettes
  225.     
  226.     
  227.     h% = OpenClipboard(xyz.hWnd)
  228.     If h% = 0 Then
  229.         MsgBox "Can't open clipboard"
  230.         End
  231.     End If
  232.     h% = SetClipboardData(CF_PALETTE, UsePalettes%)
  233.     h% = CloseClipboard()
  234.     xyz.faded.Picture = Clipboard.GetData(CF_PALETTE)
  235.     ' don't own them any more, so don't mess with them.
  236.  
  237.     
  238.  
  239. End Sub
  240.  
  241.